home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22s.zip / MULTI.4TH < prev    next >
Text File  |  1994-10-30  |  12KB  |  459 lines
  1. \ ForthCMP Multitasking Module 
  2. \ Copyright 1987 (C) By Thomas Almy.  All rights reserved.
  3.  
  4. \ Permission is granted to registered users of ForthCMP to sell or distribute
  5. \ computer programs incorporating the compiled contents of this file.
  6.  
  7. \ IBM BIOS is used for terminal I/O.
  8.  
  9. \ See the manual for usage of this module.
  10.  
  11. \   IBM is a trademark of International Business Machines, Inc.
  12.  
  13.  .( LOADING MULTI) CR
  14. FIND EMIT? [IF] DROP 1 [ELSE] 0 [THEN] CONSTANT facl  \ FACILITY Wordset used
  15. INCLUDE INTS
  16. INCLUDE FARMEM1
  17. 10
  18.  
  19. DECIMAL  
  20.  
  21. 0 0 IN/OUT NEED SINGLE 
  22. 0 0 IN/OUT NEED MULTI
  23. 0 0 IN/OUT NEED PAUSE
  24. 0 0 IN/OUT NEED end-timer
  25. 0 0 IN/OUT NEED start-timer
  26.  
  27. VARIABLE ?multi         \ true if multitasking turned on
  28. VARIABLE user           \ disp into user segment--used at compile time
  29. VARIABLE CTASK          \ pointer to task list
  30. VARIABLE dispused       \ semaphore for display output
  31. VARIABLE inaccept       \ executing ACCEPT -- only one at a time, please!
  32.  
  33.  \ Semaphores
  34.  
  35. 1 0 IN/OUT
  36. : SEMA BEGIN DUP @ WHILE PAUSE REPEAT ON ;
  37.  
  38. 1 0 IN/OUT
  39. : PHORE  OFF PAUSE ;
  40.  
  41.  
  42. 0 0 IN/OUT 
  43. : BYE  end-timer bye ;
  44.  
  45.  \ Memory management interface
  46. 1 1 IN/OUT
  47. : GET malloc IF    ." OUT OF MEMORY " BYE THEN ;
  48.  
  49.  \ USER VARIABLES 
  50. H: UALLOT  DSEG user @  +  user ! ;
  51. 1 2 IN/OUT
  52. H: UCREATE user @ CONSTANT ;
  53. H: UVARIABLE  UCREATE 2 UALLOT ;
  54. H: URESET DSEG  0 user ! ;
  55. URESET
  56.  \ redefinition of primitive I/O functions
  57. HEX
  58. 0 0 IN/OUT
  59. CODE setcursor  \ set the cursor to the correct location
  60.     CTASK [] BX MOV
  61.     CS: 12 +[BX] DH MOV     \ Y value
  62.     CS: 14 +[BX] DL MOV     \ X value
  63.     BH BH XOR
  64.     2 # AH MOV
  65.     10 INT
  66.     RET
  67. END-CODE \ setcursor
  68.  
  69. 0 0 IN/OUT
  70. CODE getcursor  \ get the correct cursor coordinates
  71.     3 # AH MOV
  72.     BH BH XOR
  73.     10 INT
  74.     CTASK [] BX MOV
  75.     DH CS: 12 +[BX] MOV     \ Y value
  76.     DL CS: 14 +[BX] MOV     \ X value
  77.     RET
  78. END-CODE \ getcursor
  79.  
  80. 2 0 IN/OUT
  81. : AT-XY  CTASK @ 12 + CS: 2! ;
  82.  
  83. 0 2 IN/OUT
  84. : ?XY     CTASK @ 12 + CS: 2@ ;
  85.  
  86. 1 0 IN/OUT
  87. CODE emit
  88.     0E # AH MOV
  89.     BX BX XOR
  90.     10 INT
  91.     RET 
  92. END-CODE
  93.  
  94. 0 0 IN/OUT 
  95. CODE PAGE
  96.   CX CX XOR CX ES >SEG  ES: 44A [] DL MOV DL DEC ES: 484 [] DH MOV
  97.   DH DX OR =0 IF, 18 # DH MOV THEN, 7 # BH MOV 600 # AX MOV
  98.   10 INT  RET  
  99. END-CODE
  100.  
  101. 0 1 IN/OUT
  102. facl [IF]
  103. CODE EKEY?
  104. [ELSE]
  105. CODE KEY?
  106. [THEN]
  107.     CALL' PAUSE     \ allow another task to execute
  108.     1 # AH MOV 
  109.     16 INT 
  110.     0 # AX MOV
  111.     =0 ~ IF, AX DEC  THEN,
  112.     RET
  113. END-CODE \ KEY?
  114.  
  115. : PAD CTASK @ 18 + CS: @ ;
  116.  
  117. DECIMAL
  118.  
  119. : EMIT 
  120.     dispused SEMA 
  121.     setcursor
  122.     emit
  123.     getcursor
  124.     dispused PHORE ;
  125.  
  126. : TYPE 
  127.     dispused SEMA 
  128.     setcursor
  129.     0 ?DO COUNT emit LOOP DROP 
  130.     getcursor
  131.     dispused PHORE ;
  132.  
  133. : CS:TYPE
  134.     dispused SEMA
  135.     setcursor
  136.     0 ?DO CS: COUNT emit LOOP DROP
  137.     getcursor
  138.     dispused PHORE ;
  139.  
  140. : SPACES        \ send out all characters in a burst
  141.     dispused SEMA
  142.     setcursor
  143.     DUP 0> IF 0 DO BL emit LOOP  ELSE DROP THEN
  144.     getcursor
  145.     dispused PHORE ;
  146.  
  147. facl [IF]
  148. VARIABLE pchr -1 pchr !
  149. : KEY  pchr @ 0< 0= IF pchr @ pchr ON EXIT THEN
  150.   BEGIN EKEY EKEY>CHAR 0= WHILE DROP REPEAT ;
  151. : KEY? pchr @ 0< 0= IF TRUE EXIT THEN
  152.   BEGIN EKEY? setcursor WHILE EKEY EKEY>CHAR IF pchr ! TRUE EXIT THEN 
  153.   DROP REPEAT FALSE ;
  154. : EKEY BEGIN EKEY? setcursor UNTIL 0 7 BDOS 
  155.       ?DUP 0= IF BEGIN EKEY? setcursor UNTIL  0 7 BDOS 256 + THEN ;
  156. [ELSE]
  157. : KEY  BEGIN KEY? setcursor UNTIL  0 8 BDOS ;
  158. [THEN]
  159.  
  160.  \ ACCEPT
  161.  
  162. 0 0 IN/OUT
  163. : bu  8 emit BL emit 8 emit ;
  164.  
  165. : ACCEPT
  166.     inaccept SEMA       \ too hard if two or more tasks want input at once!
  167.     >R 0
  168.     BEGIN
  169.         KEY  dispused SEMA  setcursor  CASE
  170.         [CTRL] [ OF 0 ?DO  bu LOOP 0 ENDOF
  171.         [CTRL] H OF DUP IF bu 1- THEN ENDOF
  172.         [CTRL] M OF 
  173.             NIP R> DROP 
  174.             getcursor 
  175.             dispused PHORE 
  176.             inaccept PHORE 
  177.             EXIT ENDOF
  178.         ( ELSE ) OVER R@ <> IF DUP >R emit
  179.             2DUP + R> SWAP C! 1+ 0 THEN
  180.         ENDCASE
  181.         getcursor dispused PHORE
  182.     AGAIN ;
  183.  
  184.  
  185.  \ TASK CREATION 
  186. HEX
  187. H: TASK              \ values after INIT-TASKS:
  188.    CSEG CREATE HERE E92E ,    \ DISP 0 -- JMP ( task asleep )
  189.    DSEG CTASK @ ,  CTASK !    \     02 -- relative addr nxt task
  190.    user @ ,                   \     04 -- size of user area (not used?)
  191.    0 ,                        \     06 -- SS register contents
  192.    user @ pssize 10 * + ,     \     08 -- SP register contents
  193.    user @ pssize 10 * + rssize + , \     0A -- BP register contents
  194.    ,                          \     0C -- PC contents
  195. \ the following fields are for per-task variables
  196. \ and could be selectively elimiated if not needed if space is 
  197. \ at a premium.  In that case, offsets may need to be adjusted
  198. \ for words which use latter fields.
  199.    0 ,                        \     0E -- Message list
  200.    0 ,                        \     10 -- Timer
  201.    0 ,                        \     12 -- Y cursor coordinate
  202.    0 ,                        \     14 -- X cursor coordinate
  203.    0 ,                        \     16 -- Exception frame pointer
  204.    DSEG HERE 80 ALLOT 22 + ,  \     18 -- PAD, a per-task work area
  205. ; 
  206. 0 [IF]
  207. Initially, DISP 2 has absolute address of next task. 
  208. This value as well as DISP 6 get
  209. filled in by INIT-TASKS when application is run.
  210. [THEN]
  211.  
  212. CSEG  CREATE MAIN-TASK  \ Give it a name
  213. HERE DSEG CTASK !             \ Task list points to it
  214. 80CD ,                        \ DISP 0 -- INT 80 (task awake)
  215.    0 ,                        \     02 -- relative addr next task
  216.    0 ,                        \     04 -- NOT USED
  217.    0 ,                        \     06 -- SS register contents
  218.    0 ,                        \     08 -- SP register contents
  219.    0 ,                        \     0A -- BP register contents
  220.    0 ,                        \     0C -- PC contents
  221.    0 ,                        \     0E -- Message list
  222.    0 ,                        \     10 -- Timer
  223.    0 ,                        \     12 -- Y cursor coordinate
  224.    0 ,                        \     14 -- X cursor coordinate
  225.    0 ,                        \     16 -- Exception Frame Pointer
  226.    DSEG HERE 80 ALLOT 22 + ,  \     18 -- PAD, a per-task work area
  227. 0 [IF]
  228. DISP-2, 6, 12, and 14 get filled in by INIT-TASK.  -8 -0A and -0C
  229. are filled by first task swap (which is done by INIT-TASK).
  230. [THEN]
  231.  
  232.  \ TASK INITIALIZATION
  233. 0 0 IN/OUT 
  234. : INIT-TASKS \ This MUST be executed to start multitasking
  235.     CTASK @
  236.     BEGIN ?DUP WHILE  \ for each task DO:
  237.         CELL+ DUP CS: @ IF  \ one follows, this isn't main task
  238.             DUP 8 + CS: @ 10 + 4 RSHIFT  GET 
  239.          OVER 4 + CS: ! \ stackseg
  240.             DUP CS: @ TUCK   \ next task
  241.         ELSE
  242.             0 SWAP CTASK @ \ next task is head of list
  243.         THEN
  244.         OVER - CELL- SWAP CS: !  
  245.     REPEAT
  246.     MAIN-TASK CTASK !  
  247.     getcursor       \ sets main task cursor
  248.     ?SS: MAIN-TASK 6 + CS: !    \ sets main task stack segment
  249.     start-timer
  250.     MULTI ( GO!!! ) ;
  251.  
  252.  \ TASK DISPATCHER
  253. CODE PAUSE  
  254.     0 # ?multi [] CMP  
  255.     =0 IF, RET THEN,
  256.     CTASK [] BX MOV         \ current task
  257.     CS: 0C +[BX] POP        \ save PC
  258.     BP CS: 0A +[BX] MOV     \ save BP
  259.     SP CS: 08 +[BX] MOV     \ save SP
  260.     CS: 2 +[BX] BX ADD  
  261.     4 # BX ADD  
  262.     CLI                \ no ints during dispatch
  263.     BX JMPI  ( dispatch )
  264. END-CODE \ PAUSE
  265.  
  266. 0 [IF]
  267. Tasks are linked together so that jumping to a task will cause
  268. jumping to the next if it is asleep, or doing an INT 80 if it
  269. is awake.  Thanks to Henry Laxen's Forth 83 model for the
  270. technique.
  271. [THEN]
  272.  
  273. L: start-task ( the INT80 routine )  
  274.     BX POP 
  275.     BX DEC 
  276.     BX DEC                  \ Pointer to the task
  277.     CS: 6 +[BX] SS >SEG     \ restore stack segment
  278.     CS: 8 +[BX] SP MOV      \ restore SP
  279.     STI                     \ Interrupts are safe now
  280.     CS: 0A +[BX] BP MOV     \ restore BP
  281.     BX  CTASK [] MOV        \ current task
  282.     CS: 0C +[BX] JMPI       \ go!
  283. FORTH \ start-task 
  284. 0 [IF]
  285. This code starts up a new task by setting up all registers,
  286. fixing CTASK, and jumping to where we left off.
  287. [THEN]
  288.  
  289.  \ TASK MANAGEMENT
  290. : SINGLE  ?multi OFF ;
  291.  
  292. : MULTI   ?multi ON
  293.     ?CS: start-task 0 200  2!L  \ install interrupt vector
  294.     PAUSE  \ start with a task swap
  295. ;
  296.  
  297. 1 0 IN/OUT
  298. : WAKE 80CD CS: <- ;
  299.  
  300. 1 0 IN/OUT
  301. \ the 2e prefix byte (CS override) makes the jmp instruction 4 bytes long
  302. : SLEEP (  task -- )   E92E CS: <- ;
  303.  
  304. 1 1 IN/OUT
  305. : WAITING?  10 + CS: @ 0<> ;
  306.  
  307. 0 0 IN/OUT
  308. : STOP  CTASK @ SLEEP PAUSE ;
  309.  
  310. 0 1 IN/OUT
  311. : ACTIVE-TASKS
  312.     0 CTASK @
  313.     BEGIN
  314.         DUP WAITING? IF SWAP 1+ SWAP ELSE 
  315.             DUP CS: @ 80CD = IF SWAP 1+ SWAP THEN THEN \ check for active
  316.         DUP CELL+ CS: @ + 4 + \ address of next task
  317.     DUP CTASK @ = UNTIL     \ Loop until back to start
  318.     DROP ( task address )
  319. ;
  320.  
  321.  \ MESSAGE PASSING
  322. 0 1 IN/OUT
  323. : MESSAGE?  CTASK @ 0E + CS: @ ;
  324.  
  325. 0 1 IN/OUT
  326. : GET-MESSAGE  
  327.     BEGIN MESSAGE? ?DUP 0= WHILE STOP REPEAT
  328.     DUP  0 @L CTASK @ 0E + CS: !         \ Unlink message
  329. ;   
  330.  
  331. 1 1 IN/OUT
  332. : MESSAGES
  333.     0 SWAP 0E + CS: @ ?DUP IF
  334.         BEGIN SWAP 1+ SWAP  0 @L  ?DUP 0= UNTIL
  335.     THEN ;
  336.  
  337. 2 0 IN/OUT
  338. : SEND-MESSAGE 
  339.     OVER 0 SWAP 0 !L        \ set message's next field to NIL
  340.     DUP WAITING? 0= IF DUP WAKE THEN \ fire up receiving task
  341.                                 \ unless waiting for timer
  342.     0E + DUP CS: @ ?DUP IF  \ Existing messages in queue
  343.         NIP
  344.         BEGIN DUP 0 @L ?DUP WHILE NIP REPEAT \ find end of list
  345.         0 !L  \ store message at end of list
  346.     ELSE
  347.         CS: !     \ no existing messages, put at head of queue.
  348.     THEN
  349.     PAUSE ;  \ Give it a chance to run
  350.  
  351.  \ control-break handler
  352. \ always gets control and (currently) dumps task information
  353.  
  354. 2VARIABLE cb_save
  355.  
  356. 1B CONSTANT cb_int
  357.  
  358. 0 0 IN/OUT
  359. : cbt  
  360.     PAGE 
  361.     SINGLE
  362.     end-timer
  363.     ." Task statistics: "
  364.     MAIN-TASK \ start with first
  365.     BEGIN CR
  366.         HEX DUP 0 <# # # # # #> TYPE SPACE \ address
  367.         DUP WAITING? IF ." Waiting " DUP 10 + CS: @ . ." ticks" ELSE 
  368.             DUP CS: @ 80CD = IF ." Active" ELSE ." Sleeping" THEN THEN 
  369.         DUP CELL+ CS: @ + 4 + \ address of next task
  370.     DUP MAIN-TASK = UNTIL     \ Loop until back to start
  371.     DROP ( task address )
  372.     bye
  373. ;
  374.  
  375.  
  376. ' cbt TASK cb-task
  377.  
  378.  
  379. L: cb_handler ( actual interrupt handler )
  380.       80CD # CS: cb-task [] MOV \ wake cb task
  381.     STI
  382.     IRET FORTH
  383.  
  384.  
  385.  \ timer
  386.  
  387. 1C CONSTANT t_int               \ timer interupt vector number
  388. CSEG
  389. CREATE t_save 4 ALLOT           \ original interupt vector
  390. L: t_handler
  391.     PUSHF CS: t_save CALLF    \ do original functions
  392.     BX PUSH
  393.     MAIN-TASK # BX MOV ( start of list )
  394.     BEGIN,  
  395.         CS: 0 # 10 +[BX] CMP =0 ~ IF, ( non_zero time )
  396.             CS: 10 +[BX] DEC  ( count down )
  397.             =0 IF, 80CD # CS: [BX] MOV THEN, ( wake task )
  398.         THEN,
  399.         CS: 2 +[BX] BX ADD 
  400.         4 # BX ADD ( next task )
  401.         MAIN-TASK # BX CMP  
  402.     =0 UNTIL, ( back at start? )
  403.     BX POP 
  404.     IRET
  405. FORTH \ t_handler
  406.  
  407. \ timer start and end                          08:09 11/18/85
  408.  
  409. : start-timer  \ and control-break handler
  410.     t_int get-handler  t_save CS: 2!
  411.     ?CS: t_handler t_int set-handler
  412.     cb_int get-handler cb_save 2!
  413.     ?CS: cb_handler cb_int set-handler
  414. ;
  415.  
  416. : end-timer
  417.     t_save CS: 2@  t_int set-handler
  418.     cb_save 2@ cb_int set-handler
  419. ;
  420.  
  421. 2 0 IN/OUT
  422. : TIME-OUT ( ticks task -- )  DUP SLEEP 10 + CS: ! ;
  423.  
  424. 1 0 IN/OUT
  425. DECIMAL
  426. : MS ( ticks -- ) 182 10000 */ CTASK @ TIME-OUT PAUSE ;
  427. HEX
  428.  
  429.  \ Exception Wordset
  430.  
  431. CODE CATCH 
  432.   SI POP  AX POP  \ retAddr execAddr
  433.   CTASK [] BX MOV
  434.   BP DEC BP DEC SI [BP] MOV
  435.   BP DEC BP DEC SP [BP] MOV
  436.   BP DEC BP DEC CS: 16 +[BX] CX MOV  CX [BP] MOV
  437.   BP CS: 16 +[BX] MOV
  438.   AX CALLI
  439.   [BP] AX MOV  AX CS: 16 +[BX] MOV  
  440.   AX AX XOR  AX PUSH
  441.   4 +[BP] AX MOV  6 # BP ADD  
  442.   AX JMPI
  443. END-CODE
  444.  
  445. 1 0 IN/OUT
  446. CODE throw
  447.   CTASK [] BX MOV
  448.   CS: 16 +[BX] BP MOV [BP] BX MOV BX CS: 16 +[BX] MOV
  449.   2 +[BP] SP MOV  AX PUSH
  450.   4 +[BP] AX MOV
  451.   6 # BP ADD  AX JMPI
  452. END-CODE
  453.  
  454. : THROW  ?DUP IF CTASK @ 16 + CS: @ IF throw THEN
  455.        ." Uncaught THROW: " . BYE THEN ;
  456.  
  457.  
  458. DSEG 0A = [IF] DECIMAL [THEN]
  459.